package WebPAC::Output::TT;

use warnings;
use strict;

use base qw/WebPAC::Common/;

use Template;
use List::Util qw/first/;
use Data::Dumper;
use Encode;

=head1 NAME

WebPAC::Output::TT - use Template Toolkit to produce output

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

=head1 SYNOPSIS

Produce output using Template Toolkit.

=head1 FUNCTIONS

=head2 new

Create new instance.

 my $tt = new WebPAC::Output::TT(
 	include_path => '/path/to/conf/output/tt',
	filters => {
		filter_1 => sub { uc(shift) },
	},
 );

By default, Template Toolkit will C<EVAL_PERL> if included in templates.

=cut

sub new {
	my $class = shift;
	my $self = {@_};
	bless($self, $class);

	my $log = $self->_get_logger;

	# create Template toolkit instance
	$self->{'tt'} = Template->new(
		INCLUDE_PATH => $self->{'include_path'},
		#FILTERS => $self->{'filters'},
		EVAL_PERL => 1,
	);
	
	$log->logdie("can't create TT object: $Template::ERROR") unless ($self->{'tt'});

	$log->debug("filters defined: ",Dumper($self->{'filters'}));

	$self ? return $self : return undef;
}


=head2 apply

Create output from in-memory data structure using Template Toolkit template.

 my $text = $tt->apply(
 	template => 'text.tt',
	data => $ds,
	record_uri => 'database/prefix/mfn',
 );

It also has follwing template toolikit filter routies defined:

=cut

sub apply {
	my $self = shift;

	my $args = {@_};

	my $log = $self->_get_logger();

	foreach my $a (qw/template data/) {
		$log->logconfess("need $a") unless ($args->{$a});
	}

=head3 tt_filter_type

filter to return values of specified from $ds, usage from TT template is in form
C<d('FieldName','delimiter')>, where C<delimiter> is optional, like this:

  [% d('Title') %]
  [% d('Author',', ' %]

=cut

	sub tt_filter_type {
		my ($data,$type) = @_;
		
		die "no data?" unless ($data);
		$type ||= 'display';

		my $default_delimiter = {
			'display' => '&#182;<br/>',
			'index' => '\n',
		};

		return sub {

			my ($name,$join) = @_;

			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
			# Hm? Should we die here?
			return unless ($name);

			my $item = $data->{'data'}->{$name} || return;

			my $v = $item->{$type} || return;

			if (ref($v) eq 'ARRAY') {
				if ($#{$v} == 0) {
					$v = $v->[0];
				} else {
					$join = $default_delimiter->{$type} unless defined($join);
					$v = join($join, @{$v});
				}
			} else {
				warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
			}

			return $v;
		}
	}

	$args->{'d'} = tt_filter_type($args, 'display');
	$args->{'display'} = tt_filter_type($args, 'display');

=head3 tt_filter_search

filter to return links to search, usage in TT:

  [% search('FieldToDisplay','FieldToSearch','optional delimiter', 'optional_template.tt') %]

=cut

	sub tt_filter_search {

		my ($data) = @_;

		die "no data?" unless ($data);
		
		return sub {

			my ($display,$search,$delimiter,$template) = @_;
			
			# default delimiter
			$delimiter ||= '&#182;<br/>',

			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
			# Hm? Should we die here?
			return unless ($display);

			my $item = $data->{'data'}->{$display} || return;

			return unless($item->{'display'});
			if (! $item->{'search'}) {
				warn "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)";
				return;
			}

			my @warn;
			foreach my $type (qw/display search/) {
				push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
			}

			if (@warn) {
				warn("TT filter search(): " . join(",", @warn) . ", skipping");
				return;
			}
			my @html;

			my $d_el = $#{ $item->{'display'} };
			my $s_el = $#{ $item->{'search'} }; 

			# easy, both fields have same number of elements or there is just
			# one search and multiple display
			if ( $d_el == $s_el || $s_el == 0 ) {

				foreach my $i ( 0 .. $d_el ) {

					my $s;
					if ($s_el > 0) {
						$s = $item->{'search'}->[$i];
						die "can't find value $i for type search in field $search" unless (defined($s));
					} else {
						$s = $item->{'search'}->[0];
					}
					#$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
					$s = __quotemeta( $s );

					my $d = $item->{'display'}->[$i];
						die "can't find value $i for type display in field $display" unless (defined($d));

					my $template_arg = '';
					$template_arg = qq{,'$template'} if ($template);

					if ($s && ! $d) {
						$d = $s;
					} elsif (! $s && $d) {
						$s = $d;
					}

					push @html, qq{<a href="#" onclick="return search_via_link('$search','$s'${template_arg})">$d</a>} if ($s && $d);
				}

				return join($delimiter, @html);
			} else {
				my $html = qq{<div class="notice">WARNING: we should really support if there is $d_el display elements and $s_el search elements, but currently there is no nice way to do so, so we will just display values</div>};
				my $v = $item->{'display'};

				if ($#{$v} == 0) {
					$html .= $v->[0];
				} else {
					$html .= join($delimiter, @{$v});
				}
				return $html;
			}
		}
	}

	$args->{'search'} = tt_filter_search($args);

=head3 load_rec

Used mostly for onClick events like this:

  <a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>

It will automatically do sanity checking and create correct JavaScript code.

=cut

	$args->{'load_rec'} = sub {
		my @errors;

		my $record_uri = shift or push @errors, "record_uri missing";
		my $template = shift or push @errors, "template missing";

		if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
			push @errors, "invalid format of record_uri: $record_uri";
		}

		if (@errors) {
			return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
		} else {
			return "load_rec('$record_uri','$template'); return false;";
		}
	};

=head3 load_template

Used to re-submit search request and load results in different template

  <a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>

=cut

	$args->{'load_template'} = sub {
		my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
		return "load_template($template); return false;";
	};

	if ($self->{filters}) {
		$args->{f} = $self->{filters};
		$log->debug("using f.filters");
	}

	my $out;

	$self->{'tt'}->process(
		$args->{'template'},
		$args,
		\$out
	) || $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );

	return $out;
}

=head2 to_file

Create output from in-memory data structure using Template Toolkit template
to a file.

 $tt->to_file(
        file => 'out.txt',
 	template => 'text.tt',
	data => $ds
 );

=cut

sub to_file {
	my $self = shift;

	my $args = {@_};

	my $log = $self->_get_logger();

	my $file = $args->{'file'} || $log->logconfess("need file name");

	$log->debug("creating file ",$file);

	open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
	print $fh $self->output(
		template => $args->{'template'},
		data => $args->{'data'},
	) || $log->logdie("print: $!");
	close($fh) || $log->logdie("close: $!");

	return 1;
}


=head2 __quotemeta

Helper to quote JavaScript-friendly characters

=cut

sub __quotemeta {
	local $_ = shift;
	$_ = decode('iso-8859-2', $_);

	s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge if ( Encode::is_utf8($_) );
	{
		use bytes;  
		s<((?:[^ \x21-\x7E]|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
	}

	s/\\x09/\\t/g;
	s/\\x0A/\\n/g;
	s/\\x0D/\\r/g;
	s/"/\\"/g;
	s/\\x5C/\\\\/g;

	return $_;
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Output::TT
